Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue54/System/FileSysDemo/UFileSys.pas

Pascal/Delphi Source File | 2000-01-07 | 23.0 KB | 704 lines

unit UFileSys;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, ExtCtrls;

type
  TForm1 = class(TForm)
    DriveList: TComboBox;
    Label1: TLabel;
    VolSize: TLabel;
    VolName: TLabel;
    FSystem: TLabel;
    SerNum: TLabel;
    DrvType: TLabel;
    FreeSp: TLabel;
    Bevel1: TBevel;
    FolderList: TComboBox;
    Label2: TLabel;
    Label16: TLabel;
    CurFolder: TEdit;
    GroupBox1: TGroupBox;
    cbHidden: TCheckBox;
    cbSystem: TCheckBox;
    cbReadOnly: TCheckBox;
    cbArchive: TCheckBox;
    FileList: TListBox;
    FileCount: TLabel;
    TotFileSize: TLabel;
    Button1: TButton;
    Bevel2: TBevel;
    Label3: TLabel;
    WatchDirName: TEdit;
    WatchSubs: TCheckBox;
    StartButton: TButton;
    StopButton: TButton;
    Bevel3: TBevel;
    Bevel4: TBevel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure DriveListChange(Sender: TObject);
    procedure FolderListChange(Sender: TObject);
    procedure CurFolderKeyPress(Sender: TObject; var Key: Char);
    procedure cbReadOnlyClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure WatchDirNameChange(Sender: TObject);
    procedure StartButtonClick(Sender: TObject);
    procedure StopButtonClick(Sender: TObject);
    procedure WatchDirNameKeyPress(Sender: TObject; var Key: Char);
  private
    { Private declarations }
    DirSize: TLargeInteger;
    procedure WatchDirChanged (Sender: TObject; CurrentFolder: Boolean);
    function FormatBigBytes (const Msg: String; Value: TLargeInteger): String;
    procedure UpdateFolderList (const FolderName: String);
    procedure SumProc (const Name: String; const Info: TSearchRec; var Continue: Boolean);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
    EFileSystem = class (Exception);

    TDriveType  = ( fsUnknown, fsNoRoot, fsRemovable, fsFixed, fsRemote, fsCDROM, fsRAMDisk );
    TDriveTypes = set of TDriveType;

    TFileType   = ( ftReadOnly, ftHidden, ftSystem, ftArchive );
    TFileTypes  = set of TFileType;

    TWalkProc = procedure (const Name: String; const Info: TSearchRec; var Continue: Boolean) of Object;
    TWatchDirProc = procedure (Sender: TObject; CurrentFolder: Boolean) of Object;

    TFileSystem = class;

    TWatchThread = class (TThread)
    private
        fOwner: TFileSystem;
        fNotifyHandle: THandle;
    protected
        procedure Execute; override;
    public
        constructor Create (AOwner: TFileSystem);
        destructor Destroy; override;
    end;

    TFileSystem = class (TComponent)
    private
        fDriveLetter: Char;
        fSerialNumber: DWord;
        fDriveType: TDriveType;
        fDriveTypes: TDriveTypes;
        fFileTypes: TFileTypes;
        fFolders: TStringList;
        fFiles: TStringList;
        fFolderName: String;
        fWatchDirectory: String;
        fWatchSubtree: Boolean;
        fWatchThread: TWatchThread;
        fWatchMask: Integer;
        fOnWatchDirChange: TWatchDirProc;
        fFileSystem, fDrives, fVolumeName: String;
        fTotalSize, fTotalFileSize, fAvailableSpace, fFreeSpace: TLargeInteger;
        procedure FileWalker (const Folder: String; Proc: TWalkProc; var Continue: Boolean);
        procedure FolderWalker (const Folder: String; Proc: TWalkProc; var Continue: Boolean);
        procedure InitDrivesList;
        procedure RefreshFolderAndFileList;
        function GetDriveCount: Integer;
        function GetIsReady: Boolean;
        procedure SignalFileNotification;
        function MatchingFile (Rec: TSearchRec): Boolean;
        procedure SetDriveLetter (Value: Char);
        function GetDriveChar (Index: Integer): Char;
        function GetUsedSpace: TLargeInteger;
        function GetSerialNumber: String;
        procedure SetFolderName (Value: String);
        procedure SetVolumeName (Value: String);
        procedure SetDriveTypes (Value: TDriveTypes);
        procedure SetFileTypes (Value: TFileTypes);
        procedure SetWatchDirectory (const DirName: String);
    public
        constructor Create (AOwner: TComponent); override;
        destructor Destroy; override;
        procedure Refresh;
        procedure TreeWalkFiles (Proc: TWalkProc);
        procedure TreeWalkFolders (Proc: TWalkProc);
        class function DirectoryExists (const DirName: String): Boolean;
        property Drives [Index: Integer]: Char read GetDriveChar;
        property Folders: TStringList read fFolders;
        property Files: TStringList read fFiles;
    published
        // File-specific stuff
        property TotalFileSize: TLargeInteger read fTotalFileSize;
        property FileTypes: TFileTypes read fFileTypes write SetFileTypes default [ftArchive];
        // Folder-specific stuff
        property FolderName: String read fFolderName write SetFolderName;
        // Drive-specific stuff....
        property DriveLetter: Char read fDriveLetter write SetDriveLetter;
        property DriveType: TDriveType read fDriveType;
        property IsReady: Boolean read GetIsReady;
        property VolumeName: String read fVolumeName write SetVolumeName;
        property FileSystem: String read fFileSystem;
        property SerialNumber: String read GetSerialNumber;
        property SerialNum: DWord read fSerialNumber;
        property TotalSize: TLargeInteger read fTotalSize;
        property FreeSpace: TLargeInteger read fFreeSpace;
        property UsedSpace: TLargeInteger read GetUsedSpace;
        property AvailableSpace: TLargeInteger read fAvailableSpace;
        property DriveCount: Integer read GetDriveCount;
        property DriveTypes: TDriveTypes read fDriveTypes write SetDriveTypes default [fsFixed];
        // Directory-watching stuff
        property WatchDirectory: String read fWatchDirectory write SetWatchDirectory;
        property WatchSubtree: Boolean read fWatchSubtree write fWatchSubtree default False;
        property WatchMask: Integer read fWatchMask write fWatchMask default File_Notify_Change_File_Name or File_Notify_Change_Dir_Name;
        property OnWatchDirChange: TWatchDirProc read fOnWatchDirChange write fOnWatchDirChange;
    end;

{ TWatchThread }

constructor TWatchThread.Create (AOwner: TFileSystem);
begin
    Inherited Create (True);
    fOwner := AOwner;
    Priority := tpLower;
    Suspended := False;
end;

destructor TWatchThread.Destroy;
begin
    if fNotifyHandle <> THandle (-1) then FindCloseChangeNotification (fNotifyHandle);
    Inherited Destroy;
end;

procedure TWatchThread.Execute;
var
    ErrCode: Integer;
begin
    // Create the synchronisation object
    fNotifyHandle := FindFirstChangeNotification (PChar (fOwner.fWatchDirectory), fOwner.fWatchSubtree, fOwner.WatchMask);
    // No synchronisation object, no comment...
    if fNotifyHandle <> THandle (-1) then while not Terminated do begin
        ErrCode := WaitForSingleObject (fNotifyHandle, 250);
        // Was it a timeout, or something more interesting ?
        case ErrCode of
             Wait_Timeout:   // Just a timeout -- ignore it....
                 ;
             Wait_Object_0:  // We've got a valid change notification
                 begin
                     Synchronize (fOwner.SignalFileNotification);
                     FindNextChangeNotification (fNotifyHandle);
                 end;

             else ;            // Something deeply bad has happened....
        end;
    end;
end;

{ TFileSystem }

constructor TFileSystem.Create (AOwner: TComponent);
begin
    Inherited Create (AOwner);
    fFolders := TStringList.Create;
    fFiles := TStringList.Create;
    fFileTypes := [ftArchive];
    fFolders.Sorted := True;
    fFiles.Sorted := True;
    SetDriveTypes ([fsFixed]);
    fWatchMask := File_Notify_Change_File_Name or File_Notify_Change_Dir_Name;
end;

destructor TFileSystem.Destroy;
begin
    // Kill the watch-thread first...
    if fWatchThread <> Nil then SetWatchDirectory ('');
    fFolders.Free;
    fFiles.Free;
    Inherited Destroy;
end;

function TFileSystem.GetDriveCount: Integer;
begin
    Result := Length (fDrives);
end;

function TFileSystem.GetDriveChar (Index: Integer): Char;
begin
    Result := #0;
    if (Index >= 0) and (Index < Length (fDrives)) then Result := fDrives [Index + 1];
end;

procedure TFileSystem.InitDrivesList;
var
    p: PChar;
    Buff: array [0..255] of Char;
begin
    fDrives := '';
    GetLogicalDriveStrings (sizeof (Buff), Buff);
    p := Buff;
    while p^ <> #0 do begin
        if TDriveType (GetDriveType (p)) in fDriveTypes then begin
            fDrives := fDrives + UpperCase (p^);
            // If this is the first, make it the current drive by default.
            if Length (fDrives) = 1 then SetDriveLetter (p^);
        end;

        Inc (p, 4);
    end;
end;

function TFileSystem.GetUsedSpace: TLargeInteger;
begin
    Result := fTotalSize - fFreeSpace;
end;

function TFileSystem.GetSerialNumber: String;
begin
    // Precision specifier in the format string ensures that leading zeroes
    // actrually get printed instead of being silently discarded....
    Result := Format ('%.4x-%.4x', [HiWord (fSerialNumber), LoWord (fSerialNumber)]);
end;

procedure TFileSystem.SetDriveLetter (Value: Char);
begin
    Value := UpCase (Value);
    if (Value <> fDriveLetter) and (Pos (Value, fDrives) > 0) then begin
        fDriveLetter := Value;
        fDriveType := TDriveType (GetDriveType (PChar (Value + ':\')));
        Refresh;
    end;
end;

function TFileSystem.GetIsReady: Boolean;
var
    errMode, FindErr: Integer;
    SearchRec: TSearchRec;
begin
    Result := fDriveType in [fsFixed, fsRemote, fsRAMDisk];
    if not Result then begin
        errMode := SetErrorMode (sem_FailCriticalErrors);
        try
            FindErr := FindFirst (fDriveLetter + ':\', faAnyFile, SearchRec);
            try
                Result := FindErr = 2;
            finally
                FindClose (SearchRec);
            end;
        finally
            SetErrorMode (errMode);
        end;
    end;
end;

procedure TFileSystem.SetDriveTypes (Value: TDriveTypes);
begin
    if Value <> fDriveTypes then begin
        fDriveTypes := Value;
        InitDrivesList;
    end;
end;

procedure TFileSystem.Refresh;
var
    Junk: DWord;
    szVolumeName, szFileSystem: array [0..255] of char;
begin
    // Initialise drive-information properties
    if not GetIsReady then raise EFileSystem.Create ('Drive not ready');
    GetDiskFreeSpaceEx (PChar (fDriveLetter + ':\'), fAvailableSpace, fTotalSize, @fFreeSpace);
    GetVolumeInformation (PChar (fDriveLetter + ':\'), szVolumeName, sizeof (szVolumeName),
                          @fSerialNumber, Junk, Junk, szFileSystem, sizeof (szFileSystem));
    fVolumeName := szVolumeName;
    fFileSystem := szFileSystem;
    SetFolderName ('');
end;

procedure TFileSystem.SetVolumeName (Value: String);
begin
    if GetIsReady and (fVolumeName <> Value) then begin
        if Length (Value) > 11 then Value := Copy (Value, 1, 11);
        SetVolumeLabel (PChar (fDriveLetter + ':\'), PChar (Value));
        Refresh; // Ensure fVolumeName reflects reality.....
    end;
end;

procedure TFileSystem.SetFolderName (Value: String);
var
    Idx: Integer;
begin
    // Do the trivial stuff first....
    if Value = '.' then Exit;
    if Value = '' then Value := fDriveLetter + ':\';

    // Handle a request to go up one level
    if Value = '..' then begin
       if Length (fFolderName) = 3 then Exit; // Already at root
       Idx := Length (fFolderName) - 1;
       while fFolderName [Idx] <> '\' do Dec (Idx);
       Value := Copy (fFolderName, 1, Idx);
    end;

    // Handle a relative path (no leading drive letter or backslash)
    if (Value [1] <> '\') and (Value [2] <> ':') then Value := fFolderName + Value;

    // Handle an absolute path (no leading drive letter)
    if Value [1] = '\' then Value := fDriveLetter + ':' + Value;

    // Handle a path -- with drive letter
    if Value [2] = ':' then begin
        Value [1] := UpCase (Value [1]);
        if Value [1] <> fDriveLetter then Exit;
        if Value [3] <> '\' then Value := fFolderName + Copy (Value, 3, MaxInt);
    end;

    // At this point, Value should be in the form X:\YYYYYY
    // Now, we need to check that the wanted path exists
    if not DirectoryExists (Value) then Exit;

    // Finally, set the new folder name and refresh folder list
    if Value [Length (Value)] <> '\' then Value := Value + '\';
    if AnsiLowerCaseFileName (Value) <> AnsiLowerCaseFileName (fFolderName) then begin
        fFolderName := Value;
        RefreshFolderAndFileList;
    end;
end;

procedure TFileSystem.SetFileTypes (Value: TFileTypes);
begin
    if Value <> fFileTypes then begin
        fFileTypes := Value;
        RefreshFolderAndFileList;
    end;
end;

class function TFileSystem.DirectoryExists (const DirName: String): Boolean;
var
    OldDir: String;
begin
    OldDir := GetCurrentDir;
    try
        Result := SetCurrentDir (DirName);
    finally
        SetCurrentDir (OldDir);
    end;
end;

function TFileSystem.MatchingFile (Rec: TSearchRec): Boolean;
begin
    Result := True;
    // Read-only file ?
    if ((Rec.Attr and faReadOnly) <> 0) and (ftReadOnly in fFileTypes) then Exit;
    // Hidden-file ?
    if ((Rec.Attr and faHidden) <> 0) and (ftHidden in fFileTypes) then Exit;
    // System-file ?
    if ((Rec.Attr and faSysFile) <> 0) and (ftSystem in fFileTypes) then Exit;
    // Archive file ?
    if ((Rec.Attr and faArchive) <> 0) and (ftArchive in fFileTypes) then Exit;
    Result := Rec.Attr = 0;
end;

procedure TFileSystem.RefreshFolderAndFileList;
var
    Err: Integer;
    Rec: TSearchRec;
begin
    fFolders.Clear;  fFiles.Clear;  fTotalFileSize := 0;
    Err := FindFirst (fFolderName + '*.*', faAnyFile, Rec);
    try
       while Err = 0 do begin
           if (Rec.Attr and faDirectory) <> 0 then begin
               // Ignore the accursed '.' and '..' names
               if Rec.Name [1] <> '.' then fFolders.Add (Rec.Name);
           end else if (Rec.Attr and faVolumeID) = 0 then
               // Not a directory, not a volumeID - must be a file!
               if MatchingFile (Rec) then begin
                   fFiles.Add (Rec.Name);
                   fTotalFileSize := fTotalFileSize + Rec.Size;
               end;

           Err := FindNext (Rec);
       end;
    finally
        FindClose (Rec);
    end;
end;

procedure TFileSystem.TreeWalkFiles (Proc: TWalkProc);
var
    Continue: Boolean;
begin
    Screen.Cursor := crHourGlass;
    try
        Continue := True;
        if Assigned (Proc) then FileWalker (fFolderName, Proc, Continue);
    finally
        Screen.Cursor := crDefault;
    end;
end;

procedure TFileSystem.TreeWalkFolders (Proc: TWalkProc);
var
    Continue: Boolean;
begin
    Screen.Cursor := crHourGlass;
    try
        Continue := True;
        if Assigned (Proc) then FolderWalker (fFolderName, Proc, Continue);
    finally
        Screen.Cursor := crDefault;
    end;
end;

procedure TFileSystem.FileWalker (const Folder: String; Proc: TWalkProc; var Continue: Boolean);
var
    Err: Integer;
    Rec: TSearchRec;
begin
    Err := FindFirst (Folder + '*.*', faAnyFile, Rec);
    try
       while (Err = 0) and Continue do begin
           if (Rec.Attr and faDirectory) <> 0 then begin
               // Ignore the accursed '.' and '..' names
               if Rec.Name [1] <> '.' then FileWalker (Folder + Rec.Name + '\', Proc, Continue);
           end else if (Rec.Attr and faVolumeID) = 0 then
               // Not a directory, not a volumeID - must be a file!
               if MatchingFile (Rec) then begin
                   Proc (Folder + Rec.Name, Rec, Continue);
               end;

           Err := FindNext (Rec);
       end;
    finally
        FindClose (Rec);
    end;
end;

procedure TFileSystem.FolderWalker (const Folder: String; Proc: TWalkProc; var Continue: Boolean);
var
    Err: Integer;
    Rec: TSearchRec;
begin
    Err := FindFirst (Folder + '*.*', faAnyFile, Rec);
    try
       while (Err = 0) and Continue do begin
           if (Rec.Attr and faDirectory) <> 0 then begin
               // Ignore the accursed '.' and '..' names
               if Rec.Name [1] <> '.' then FileWalker (Folder + Rec.Name + '\', Proc, Continue);
               Proc (Folder + Rec.Name + '\', Rec, Continue);
           end;
           Err := FindNext (Rec);
       end;
    finally
        FindClose (Rec);
    end;
end;

procedure TFileSystem.SetWatchDirectory (const DirName: String);
begin
    if fWatchDirectory <> DirName then begin
       fWatchDirectory := DirName;
       if fWatchDirectory = '' then begin
           // Stop watching...
           fWatchThread.Terminate;
           fWatchThread.WaitFor;
           fWatchThread.Free;
           fWatchThread := Nil;
       end else
           // Start watching...
           if DirectoryExists (fWatchDirectory) then
               fWatchThread := TWatchThread.Create (Self);
    end;
end;

procedure TFileSystem.SignalFileNotification;
var
    S1, S2: String;
    fCurrent: Boolean;
begin
    if Assigned (fOnWatchDirChange) then begin
        // See if we're actually pointing at the watched folder
        S1 := fWatchDirectory;  if S1 [Length (S1)] <> '\' then S1 := S1 + '\';
        S2 := fFolderName;      if S2 [Length (S2)] <> '\' then S2 := S2 + '\';
        fCurrent := CompareText (S1, S2) = 0;
        if fCurrent then RefreshFolderAndFileList;
        fOnWatchDirChange (Self, fCurrent);
    end;
end;

//--------- End of TFileSystem component ---------------------------------

var
    FileSys: TFileSystem;

procedure TForm1.FormCreate (Sender: TObject);
var
    Idx: Integer;
begin
    FileSys := TFileSystem.Create (Self);
    with FileSys do begin
        DriveTypes := [ fsFixed, fsRemote, fsCDROM ];
        for Idx := 0 to DriveCount - 1 do DriveList.Items.Add (Drives [Idx] + ':');
        DriveList.ItemIndex := 0;
        DriveListChange (Self);
        // Set File attribute checkboxes according to current 'FileTypes'
        cbReadOnly.Checked := ftReadOnly in FileTypes;
        cbHidden.Checked   := ftHidden in FileTypes;
        cbSystem.Checked   := ftSystem in FileTypes;
        cbArchive.Checked  := ftArchive in FileTypes;
        // Set Watch stuff according to FileSystem
        WatchSubs.Checked := WatchSubTree;
    end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
    FileSys.Free;
end;

function TForm1.FormatBigBytes (const Msg: String; Value: TLargeInteger): String;
var
    Dbl: Double;
begin
     Dbl := Value;
     Result := Format (Msg + ' %n', [Dbl]);
     Result := Copy (Result, 1, Length (Result) - 3) + ' bytes';
end;

procedure TForm1.DriveListChange(Sender: TObject);
var
    S: String;

    function StrDriveType (Typ: TDriveType): String;
    begin
        case Typ of
          fsRemovable: Result := 'Removable';
          fsFixed:     Result := 'Fixed    ';
          fsRemote:    Result := 'Remote   ';
          fsCDROM:     Result := 'CD-ROM   ';
          fsRAMDisk:   Result := 'RAM-Disk ';
          else         Result := '-unknown-';
        end;
    end;

begin
    with FileSys do begin
        // First, point TFileSystem object at the new drive
        DriveLetter := DriveList.Text [1];
        // Now display the various drive properties
        VolSize.Caption := FormatBigBytes ('Total size of this drive is:', TotalSize);
        S := VolumeName;  if S = '' then S := '[None]';
        VolName.Caption := Format ('Volume label of this drive is: %s', [S]);
        FSystem.Caption := Format ('File system of this drive is: %s', [FileSystem]);
        SerNum.Caption := Format ('Serial number of this drive is: %s', [SerialNumber]);
        DrvType.Caption := Format ('Type of this drive is: %s', [StrDriveType (DriveType)]);
        FreeSp.Caption := FormatBigBytes ('Free space on this drive is:', FreeSpace);
        UpdateFolderList ('');
    end;
end;

procedure TForm1.UpdateFolderList (const FolderName: String);
begin
    if FolderName <> '' then FileSys.FolderName := FolderName;
    CurFolder.Text := FileSys.FolderName;
    FolderList.Items.Assign (FileSys.Folders);
    FolderList.ItemIndex := 0;
    FileList.Items.Assign (FileSys.Files);
    FileList.ItemIndex := 0;
    FileCount.Caption := Format ('File count = %d', [FileList.Items.Count]);
    TotFileSize.Caption := FormatBigBytes ('Total size of files is:', FileSys.TotalFileSize);
end;

procedure TForm1.FolderListChange(Sender: TObject);
begin
    UpdateFolderList (FolderList.Text);
end;

procedure TForm1.CurFolderKeyPress(Sender: TObject; var Key: Char);
begin
    if Key = #13 then UpdateFolderList (CurFolder.Text);
end;

procedure TForm1.cbReadOnlyClick(Sender: TObject);
var
   ft: TFileType;
begin
    with Sender as TCheckBox do begin
        ft := TFileType (Tag);
        if Checked then FileSys.FileTypes := FileSys.FileTypes + [ft]
        else FileSys.FileTypes := FileSys.FileTypes - [ft];
        FileList.Items.Assign (FileSys.Files);
        FileList.ItemIndex := 0;
        FileCount.Caption := Format ('File count = %d', [FileList.Items.Count]);
        TotFileSize.Caption := FormatBigBytes ('Total size of files is:', FileSys.TotalFileSize);
    end;
end;

procedure TForm1.SumProc (const Name: String; const Info: TSearchRec; var Continue: Boolean);
begin
    DirSize := DirSize + Info.Size;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
    DirSize := 0;
    FileSys.TreeWalkFiles (SumProc);
    ShowMessage (FormatBigBytes ('Total size of this directory is:', DirSize));
end;

procedure TForm1.WatchDirNameChange(Sender: TObject);
begin
    StartButton.Enabled := WatchDirName.Text <> '';
end;

procedure TForm1.WatchDirChanged (Sender: TObject; CurrentFolder: Boolean);
begin
    if CurrentFolder then UpdateFolderList ('');
end;

procedure TForm1.StartButtonClick(Sender: TObject);
begin
    // See if specified directory exists
    if not FileSys.DirectoryExists (WatchDirName.Text) then ShowMessage ('Specified watch directory doesn''t exist!') else begin
       FileSys.WatchSubtree := WatchSubs.Checked;
       FileSys.OnWatchDirChange := WatchDirChanged;
       FileSys.WatchDirectory := WatchDirName.Text;
       StartButton.Enabled := False;
       WatchDirName.Enabled := False;
       StopButton.Enabled := True;
    end;
end;

procedure TForm1.StopButtonClick(Sender: TObject);
begin
    FileSys.WatchDirectory := '';
    StopButton.Enabled := False;
    StartButton.Enabled := True;
    WatchDirName.Enabled := True;
end;

procedure TForm1.WatchDirNameKeyPress(Sender: TObject; var Key: Char);
begin
    if Key = #13 then begin
        StartButton.Click;
        Key := #0;
    end;
end;

end.

autorefresh...